Companion Guide: “Extending your Ability to Extend” by Thomas Lin Pederson

Step 00: Press play on ‘Extending your Ability to Extend’ https://www.youtube.com/watch?v=uj7A3i2fi54

Verbatim approach

create_cicle

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4          ✔ readr     2.1.5     
## ✔ forcats   1.0.0          ✔ stringr   1.5.1     
## ✔ ggplot2   3.5.2.9000     ✔ tibble    3.2.1     
## ✔ lubridate 1.9.3          ✔ tidyr     1.3.1     
## ✔ purrr     1.0.2          
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

create_circle <- function(data, n){

  angles <- seq(from = 0, 
                to = 2 * pi,
                length.out = n + 1)

  data.frame(
    x = cos(angles) * data$r + data$x0,
    y = sin(angles) * data$r + data$y0,
    data
  )

}

StatCirc

StatCircle <- ggproto(`_class` = "StatCircle", 
                      `_inherit` = Stat, 
                      setup_data = function(data, params) {
  
    if (data$group[1] == -1) {
      nrows <- nrow(data)
      data$group <- seq_len(nrows)
    }
  
    data  # return data with a group variable

},
                      compute_group = function(data, scales, n = 5){create_circle(data, n = n)},
                      required_aes = c("x0", "y0", "r")
                      )

circles <- data.frame(x0 = c(-5,5), y0 = c(5, -5),
                      r = c(5, 4), class = c("A", "B"))

ggplot(circles) + 
  geom_polygon(stat = StatCircle,
               aes(x0 = x0, y0 = y0, 
                   r = r, fill = class))

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

usingfacet

ggplot(circles) + 
  geom_polygon(stat = StatCircle,
               aes(x0 = x0, y0 = y0, 
                   r = r, fill = class)) + 
  facet_wrap(~ class)

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

ggplot(cars) + 
  aes(x = speed, y = dist) + 
  geom_point() +
  aes(x0 = speed, y0 = dist, r = 1) + 
  geom_polygon(stat = StatCircle) + 
  aes(fill = speed > 15) + 
  facet_wrap(~ speed > 15)

## Warning in cos(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in sin(angles) * data$r: longer object length is not a multiple of
## shorter object length

---

---

extension

StatCirc

step 1a: write setup_data function

library(tidyverse)
setup_data_circle <- function(data, params) {
  
    if (data$group[1] == -1) {
      nrows <- nrow(data)
      data$group <- seq_len(nrows)
    }
  
    data  # return data with a group variable

}

step 1b: test setup_data data function

cars %>% 
  slice(1:5) %>% 
  mutate(group = -1) %>% # no grouping neg one is default in ggplot2
  setup_data_circle() # setup makes each row defines a group

##   speed dist group
## 1     4    2     1
## 2     4   10     2
## 3     7    4     3
## 4     7   22     4
## 5     8   16     5

cars %>% 
  slice(5:20) %>% 
  mutate(group = 2) %>% # if a group is already defined
  setup_data_circle() # setup data does not do anything

##    speed dist group
## 1      8   16     2
## 2      9   10     2
## 3     10   18     2
## 4     10   26     2
## 5     10   34     2
## 6     11   17     2
## 7     11   28     2
## 8     12   14     2
## 9     12   20     2
## 10    12   24     2
## 11    12   28     2
## 12    13   26     2
## 13    13   34     2
## 14    13   34     2
## 15    13   46     2
## 16    14   26     2

---

step 2a: write a compute_group function

We write a routine that will act on each group in the data (in this case each row)

create_circle()

---

compute_group_circle <- function(data, scales, n = 5){

  angles <- seq(from = 0, 
                to = 2 * pi,
                length.out = n + 1)

  data.frame(
    x = cos(angles) * data$r + data$x0,
    y = sin(angles) * data$r + data$y0#,
    # data
  )

}

step 2b: test compute_group row processing function

cars %>%
  rename(x0 = dist, y0 = speed) %>% 
  mutate(r = x0) %>% 
  .[1,] %>% 
  compute_group_circle(n = 6)

##   x        y
## 1 4 4.000000
## 2 3 5.732051
## 3 1 5.732051
## 4 0 4.000000
## 5 1 2.267949
## 6 3 2.267949
## 7 4 4.000000

cars %>%
  rename(x0 = dist, y0 = speed) %>% 
  mutate(r = x0) %>%
  .[5,] %>% 
  compute_group_circle(n = 6) %>% 
  ggplot() + 
  aes(x = x, y = y) +
  geom_polygon(alpha = .5) + 
  coord_equal()

Step 3: use ggproto() to create StatCircle; setup_data and compute_group functions will be inputs

StatCircle <- ggproto(`_class` = "StatCircle", 
                      `_inherit` = Stat, 
                      setup_data = setup_data_circle,
                      compute_group = compute_group_circle,
                      required_aes = c("x0", "y0", "r")
                      )

Step 5: Enjoy! Test out geom_circle

test_df <- data.frame(
  
  x0 = c(-5, 5),
  y0 = c(5, -5),
  r = c(5, 4),
  class = c("a", "b")
  
)


cars %>% 
  slice(1:5) %>% 
  ggplot() + 
  aes(x = speed, y = dist) +
  geom_point() +
  aes(x0 = speed, 
      y0 = dist, 
      r = speed/6) + 
  coord_equal() ->
baseplot

baseplot +
  geom_polygon(stat = StatCircle, n = 7, alpha = .2)

Keep testing; second guess everything; dispare

baseplot + 
  aes(fill = speed == 6) +
  geom_polygon(stat = StatCircle, n = 7, alpha = .2)

## Warning in cos(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in cos(angles) * data$r + data$x0: longer object length is not a
## multiple of shorter object length

## Warning in sin(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in sin(angles) * data$r + data$y0: longer object length is not a
## multiple of shorter object length

## Warning: The following aesthetics were dropped during statistical transformation: x0,
## y0, and r.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

baseplot + 
  aes(fill = speed > 6) +
  geom_polygon(stat = StatCircle, n = 7, alpha = .2)

## Warning in cos(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in cos(angles) * data$r + data$x0: longer object length is not a
## multiple of shorter object length

## Warning in sin(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in sin(angles) * data$r + data$y0: longer object length is not a
## multiple of shorter object length

## Warning: The following aesthetics were dropped during statistical transformation: y0,
## x0, and r.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

Look at geom_circle from ggforce; hope renewed

baseplot + 
  aes(fill = speed > 6) +
  ggforce::geom_circle(n = 5)

Verbatim approach

create_cicle

create_circle <- function(data, n){

  angles <- seq(from = 0, 
                to = 2 * pi,
                length.out = n + 1)

  data.frame(
    x = cos(angles) * data$r + data$x0,
    y = sin(angles) * data$r + data$y0,
    data
  )

}

StatCirc

StatCircle <- ggproto(`_class` = "StatCircle", 
                      `_inherit` = Stat, 
                      setup_data = function(data, params) {
  
    if (data$group[1] == -1) {
      nrows <- nrow(data)
      data$group <- seq_len(nrows)
    }
  
    data  # return data with a group variable

},
                      compute_group = function(data, scales, n = 5){create_circle(data, n = n)},
                      required_aes = c("x0", "y0", "r")
                      )

circles <- data.frame(x0 = c(-5,5), y0 = c(5, -5),
                      r = c(5, 4), class = c("A", "B"))

ggplot(circles) + 
  geom_polygon(stat = StatCircle,
               aes(x0 = x0, y0 = y0, 
                   r = r, fill = class))

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

usingfacet

ggplot(circles) + 
  geom_polygon(stat = StatCircle,
               aes(x0 = x0, y0 = y0, 
                   r = r, fill = class)) + 
  facet_wrap(~ class)

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

ggplot(cars) + 
  aes(x = speed, y = dist) + 
  geom_point() +
  aes(x0 = speed, y0 = dist, r = 1) + 
  geom_polygon(stat = StatCircle) + 
  aes(fill = speed > 15) + 
  facet_wrap(~ speed > 15)

## Warning in cos(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in sin(angles) * data$r: longer object length is not a multiple of
## shorter object length

---

ggforce:::StatCircle$compute_group

## <ggproto method>
##   <Wrapper function>
##     function (...) 
## compute_group(..., self = self)
## 
##   <Inner function (f)>
##     function (self, data, scales) 
## {
##     cli::cli_abort("Not implemented.")
## }

ggforce:::StatCircle$compute_panel

## <ggproto method>
##   <Wrapper function>
##     function (...) 
## compute_panel(...)
## 
##   <Inner function (f)>
##     function (data, scales, n = 360) 
## {
##     data$x <- NULL
##     data$y <- NULL
##     data$start <- 0
##     data$end <- 2 * pi
##     arcPaths(data, n + 1)
## }

ggforce:::StatCircle$setup_params

## <ggproto method>
##   <Wrapper function>
##     function (...) 
## setup_params(...)
## 
##   <Inner function (f)>
##     function (data, params) 
## {
##     params
## }

ggforce:::arcPaths

## function (data, n) 
## {
##     trans <- radial_trans(c(0, 1), c(0, 2 * pi), pad = 0)
##     data <- data[data$start != data$end, ]
##     data$nControl <- ceiling(n/(2 * pi) * abs(data$end - data$start))
##     data$nControl[data$nControl < 3] <- 3
##     extraData <- !names(data) %in% c("r0", "r", "start", "end", 
##         "group")
##     data$group <- make_unique(as.character(data$group))
##     paths <- lapply(seq_len(nrow(data)), function(i) {
##         path <- data_frame0(a = seq(data$start[i], data$end[i], 
##             length.out = data$nControl[i]), r = data$r[i])
##         if ("r0" %in% names(data)) {
##             if (data$r0[i] != 0) {
##                 path <- vec_rbind(path, data_frame0(a = rev(path$a), 
##                   r = data$r0[i]))
##             }
##             else {
##                 path <- vec_rbind(path, data_frame0(a = data$start[i], 
##                   r = 0))
##             }
##         }
##         path$group <- data$group[i]
##         path$index <- seq(0, 1, length.out = nrow(path))
##         path <- cbind(path, data[rep(i, nrow(path)), extraData, 
##             drop = FALSE])
##     })
##     paths <- vec_rbind(!!!paths)
##     paths <- cbind(paths[, !names(paths) %in% c("r", "a")], trans$transform(paths$r, 
##         paths$a))
##     paths$x <- paths$x + paths$x0
##     paths$y <- paths$y + paths$y0
##     if ("explode" %in% names(data)) {
##         exploded <- data$explode != 0
##         if (any(exploded)) {
##             exploder <- trans$transform(data$explode[exploded], 
##                 data$start[exploded] + (data$end[exploded] - 
##                   data$start[exploded])/2)
##             explodedPaths <- paths$group %in% which(exploded)
##             exploderInd <- as.integer(factor(paths$group[explodedPaths]))
##             paths$x[explodedPaths] <- paths$x[explodedPaths] + 
##                 exploder$x[exploderInd]
##             paths$y[explodedPaths] <- paths$y[explodedPaths] + 
##                 exploder$y[exploderInd]
##         }
##     }
##     paths[, !names(paths) %in% c("x0", "y0", "exploded")]
## }
## <bytecode: 0x7fe992d5cce8>
## <environment: namespace:ggforce>

Step 6: Post Mordem using layer_data to look at the data frame

baseplot +
  geom_polygon(stat = StatCircle, n = 7, alpha = .2) ->
p1

layer_data(p1, 2)

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded
## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

##           x         y x0 y0         r x.1 y.1 PANEL group colour      fill
## 1  4.666667  2.000000  4  2 0.6666667   4   2     1     1     NA #333333FF
## 2  4.415660  2.521221  4  2 0.6666667   4   2     1     1     NA #333333FF
## 3  3.851653  2.649952  4  2 0.6666667   4   2     1     1     NA #333333FF
## 4  3.399354  2.289256  4  2 0.6666667   4   2     1     1     NA #333333FF
## 5  3.399354  1.710744  4  2 0.6666667   4   2     1     1     NA #333333FF
## 6  3.851653  1.350048  4  2 0.6666667   4   2     1     1     NA #333333FF
## 7  4.415660  1.478779  4  2 0.6666667   4   2     1     1     NA #333333FF
## 8  4.666667  2.000000  4  2 0.6666667   4   2     1     1     NA #333333FF
## 9  4.666667 10.000000  4 10 0.6666667   4  10     1     2     NA #333333FF
## 10 4.415660 10.521221  4 10 0.6666667   4  10     1     2     NA #333333FF
## 11 3.851653 10.649952  4 10 0.6666667   4  10     1     2     NA #333333FF
## 12 3.399354 10.289256  4 10 0.6666667   4  10     1     2     NA #333333FF
## 13 3.399354  9.710744  4 10 0.6666667   4  10     1     2     NA #333333FF
## 14 3.851653  9.350048  4 10 0.6666667   4  10     1     2     NA #333333FF
## 15 4.415660  9.478779  4 10 0.6666667   4  10     1     2     NA #333333FF
## 16 4.666667 10.000000  4 10 0.6666667   4  10     1     2     NA #333333FF
## 17 8.166667  4.000000  7  4 1.1666667   7   4     1     3     NA #333333FF
## 18 7.727405  4.912137  7  4 1.1666667   7   4     1     3     NA #333333FF
## 19 6.740392  5.137416  7  4 1.1666667   7   4     1     3     NA #333333FF
## 20 5.948870  4.506198  7  4 1.1666667   7   4     1     3     NA #333333FF
## 21 5.948870  3.493802  7  4 1.1666667   7   4     1     3     NA #333333FF
## 22 6.740392  2.862584  7  4 1.1666667   7   4     1     3     NA #333333FF
## 23 7.727405  3.087863  7  4 1.1666667   7   4     1     3     NA #333333FF
## 24 8.166667  4.000000  7  4 1.1666667   7   4     1     3     NA #333333FF
## 25 8.166667 22.000000  7 22 1.1666667   7  22     1     4     NA #333333FF
## 26 7.727405 22.912137  7 22 1.1666667   7  22     1     4     NA #333333FF
## 27 6.740392 23.137416  7 22 1.1666667   7  22     1     4     NA #333333FF
## 28 5.948870 22.506198  7 22 1.1666667   7  22     1     4     NA #333333FF
## 29 5.948870 21.493802  7 22 1.1666667   7  22     1     4     NA #333333FF
## 30 6.740392 20.862584  7 22 1.1666667   7  22     1     4     NA #333333FF
## 31 7.727405 21.087863  7 22 1.1666667   7  22     1     4     NA #333333FF
## 32 8.166667 22.000000  7 22 1.1666667   7  22     1     4     NA #333333FF
## 33 9.333333 16.000000  8 16 1.3333333   8  16     1     5     NA #333333FF
## 34 8.831320 17.042442  8 16 1.3333333   8  16     1     5     NA #333333FF
## 35 7.703305 17.299904  8 16 1.3333333   8  16     1     5     NA #333333FF
## 36 6.798708 16.578512  8 16 1.3333333   8  16     1     5     NA #333333FF
## 37 6.798708 15.421488  8 16 1.3333333   8  16     1     5     NA #333333FF
## 38 7.703305 14.700096  8 16 1.3333333   8  16     1     5     NA #333333FF
## 39 8.831320 14.957558  8 16 1.3333333   8  16     1     5     NA #333333FF
## 40 9.333333 16.000000  8 16 1.3333333   8  16     1     5     NA #333333FF
##    linewidth linetype alpha
## 1        0.5        1   0.2
## 2        0.5        1   0.2
## 3        0.5        1   0.2
## 4        0.5        1   0.2
## 5        0.5        1   0.2
## 6        0.5        1   0.2
## 7        0.5        1   0.2
## 8        0.5        1   0.2
## 9        0.5        1   0.2
## 10       0.5        1   0.2
## 11       0.5        1   0.2
## 12       0.5        1   0.2
## 13       0.5        1   0.2
## 14       0.5        1   0.2
## 15       0.5        1   0.2
## 16       0.5        1   0.2
## 17       0.5        1   0.2
## 18       0.5        1   0.2
## 19       0.5        1   0.2
## 20       0.5        1   0.2
## 21       0.5        1   0.2
## 22       0.5        1   0.2
## 23       0.5        1   0.2
## 24       0.5        1   0.2
## 25       0.5        1   0.2
## 26       0.5        1   0.2
## 27       0.5        1   0.2
## 28       0.5        1   0.2
## 29       0.5        1   0.2
## 30       0.5        1   0.2
## 31       0.5        1   0.2
## 32       0.5        1   0.2
## 33       0.5        1   0.2
## 34       0.5        1   0.2
## 35       0.5        1   0.2
## 36       0.5        1   0.2
## 37       0.5        1   0.2
## 38       0.5        1   0.2
## 39       0.5        1   0.2
## 40       0.5        1   0.2

baseplot + 
  aes(fill = speed > 6) +
  geom_polygon(stat = StatCircle, n = 7, alpha = .2) ->
p2

layer_data(p2, 2) |>
  slice(1:5)

## Warning in data.frame(x = cos(angles) * data$r + data$x0, y = sin(angles) * :
## row names were found from a short variable and have been discarded

## Warning in cos(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in cos(angles) * data$r + data$x0: longer object length is not a
## multiple of shorter object length

## Warning in sin(angles) * data$r: longer object length is not a multiple of
## shorter object length

## Warning in sin(angles) * data$r + data$y0: longer object length is not a
## multiple of shorter object length

## Warning: Computation failed in `stat_circle()`.
## Caused by error in `data.frame()`:
## ! arguments imply differing number of rows: 8, 3

## data frame with 0 columns and 0 rows

verbatim

---